home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlprin.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  9.3 KB  |  458 lines
  1. /* xlprint - xlisp print routine */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <string.h>
  8.  
  9. /* external variables */
  10. extern LVAL s_printcase,k_downcase,k_const,k_nmacro;
  11. extern LVAL s_ifmt,s_ffmt;
  12. extern LVAL obarray;
  13. extern FUNDEF funtab[];
  14. extern char buf[];
  15. #ifdef PRINDEPTH
  16. extern LVAL s_printlevel, s_printlength;        /* TAA mod */
  17. #endif
  18.  
  19. /* forward declarations */
  20. #ifdef ANSI
  21. void putsymbol(LVAL fptr, char *str, int escflag);
  22. void putstring(LVAL fptr, LVAL str);
  23. void putqstring(LVAL fptr, LVAL str);
  24. void putatm(LVAL fptr, char *tag, LVAL val);
  25. void putsubr(LVAL fptr, char *tag, LVAL val);
  26. void putclosure(LVAL fptr, LVAL val);
  27. void putfixnum(LVAL fptr, FIXTYPE n);
  28. void putflonum(LVAL fptr, FLOTYPE n);
  29. void putchcode(LVAL fptr, int ch, int escflag);
  30. void putoct(LVAL fptr, int n);
  31. #else
  32. FORWARD VOID putsymbol();
  33. FORWARD VOID putstring();
  34. FORWARD VOID putqstring();
  35. FORWARD VOID putatm();
  36. FORWARD VOID putsubr();
  37. FORWARD VOID putclosure();
  38. FORWARD VOID putfixnum();
  39. FORWARD VOID putflonum();
  40. FORWARD VOID putchcode();
  41. FORWARD VOID putoct();
  42. #endif
  43.  
  44. #ifdef PRINDEPTH
  45. #ifdef ANSI
  46. void xlprintl(LVAL fptr, LVAL vptr, int flag);
  47. #else
  48. FORWARD VOID xlprintl();
  49. #endif
  50.  
  51. FIXTYPE plevel,plength;
  52.  
  53. /* xlprint - print an xlisp value */
  54. VOID xlprint(fptr,vptr,flag)
  55.   LVAL fptr,vptr; int flag;
  56. {
  57.     LVAL temp;
  58.     temp = getvalue(s_printlevel);
  59.     if (fixp(temp)) {
  60.         plevel = getfixnum(temp);
  61.     }
  62.     else {
  63.         plevel = 32767;
  64.     }
  65.     temp = getvalue(s_printlength);
  66.     if (fixp(temp)) {
  67.         plength = getfixnum(temp);
  68.     }
  69.     else
  70.         plength = 32767;
  71.     xlprintl(fptr,vptr,flag);
  72. }
  73.                 
  74. VOID xlprintl(fptr,vptr,flag)
  75. #else
  76. #define xlprintl xlprint                /* alias */
  77. VOID xlprint(fptr,vptr,flag)
  78. #endif
  79.   LVAL fptr,vptr; int flag;
  80. {
  81.     LVAL nptr,next;
  82.     int n,i;
  83. #ifdef PRINDEPTH
  84.         FIXTYPE llength;
  85. #endif
  86.  
  87.     /* print nil */
  88.     if (vptr == NIL) {
  89.         xlputstr(fptr,
  90.             (((!flag) || (getvalue(s_printcase) != k_downcase))?"NIL":"nil"));
  91.         return;
  92.     }
  93.  
  94.     /* check value type */
  95.     switch (ntype(vptr)) {
  96.     case SUBR:
  97.             putsubr(fptr,"Subr",vptr);
  98.             break;
  99.     case FSUBR:
  100.             putsubr(fptr,"FSubr",vptr);
  101.             break;
  102.     case CONS:
  103. #ifdef PRINDEPTH
  104.             if (plevel-- == 0) {            /* depth limitation */
  105.                 xlputc(fptr,'#');
  106.                 plevel++;
  107.                 break;
  108.             }
  109. #endif
  110.             xlputc(fptr,'(');
  111. #ifdef PRINDEPTH
  112.             llength = plength;
  113. #endif
  114.             for (nptr = vptr; nptr != NIL; nptr = next) {
  115. #ifdef PRINDEPTH
  116.                 if (llength-- == 0) { /* length limitiation */
  117.                     xlputstr(fptr,"... ");
  118.                     break;
  119.                 }
  120. #endif
  121.                 xlprintl(fptr,car(nptr),flag);
  122.                 if ((next = cdr(nptr)) != 0)
  123.                     if (consp(next))
  124.                         xlputc(fptr,' ');
  125.                     else {
  126.                         xlputstr(fptr," . ");
  127.                         xlprintl(fptr,next,flag);
  128.                         break;
  129.                     }
  130.             }
  131.             xlputc(fptr,')');
  132. #ifdef PRINDEPTH
  133.             plevel++;
  134. #endif
  135.             break;
  136.     case SYMBOL:
  137.             putsymbol(fptr,(char *)getstring(getpname(vptr)),flag);
  138.             break;
  139.     case FIXNUM:
  140.             putfixnum(fptr,getfixnum(vptr));
  141.             break;
  142.     case FLONUM:
  143.             putflonum(fptr,getflonum(vptr));
  144.             break;
  145.     case CHAR:
  146.             putchcode(fptr,getchcode(vptr),flag);
  147.             break;
  148.     case STRING:
  149.             if (flag)
  150.                 putqstring(fptr,vptr);
  151.             else
  152.                 putstring(fptr,vptr);
  153.             break;
  154.     case STREAM:
  155.             putatm(fptr,"File-Stream",vptr);
  156.             break;
  157.     case USTREAM:
  158.             putatm(fptr,"Unnamed-Stream",vptr);
  159.             break;
  160.     case OBJECT:
  161. #ifdef OBJPRNT
  162.             /* putobj fakes a (send obj :prin1 file) call */
  163.             putobj(fptr,vptr);
  164. #else
  165.             putatm(fptr,"Object",vptr);
  166. #endif
  167.             break;
  168.     case VECTOR:
  169. #ifdef PRINDEPTH
  170.             if (plevel-- == 0) {            /* depth limitation */
  171.                 xlputc(fptr,'#');
  172.                 plevel++;
  173.                 break;
  174.             }
  175. #endif
  176.             xlputc(fptr,'#'); xlputc(fptr,'(');
  177. #ifdef PRINDEPTH
  178.             llength = plength;
  179. #endif
  180.             for (i = 0, n = getsize(vptr); n-- > 0; ) {
  181. #ifdef PRINDEPTH
  182.                 if (llength-- == 0) { /* length limitiation */
  183.                     xlputstr(fptr,"... ");
  184.                     break;
  185.                 }
  186. #endif
  187.                 xlprintl(fptr,getelement(vptr,i++),flag);
  188.                 if (n) xlputc(fptr,' ');
  189.             }
  190.             xlputc(fptr,')');
  191. #ifdef PRINDEPTH
  192.             plevel++;
  193. #endif
  194.             break;
  195. #ifdef STRUCTS
  196.     case STRUCT:
  197.             xlprstruct(fptr,vptr,flag);
  198.             break;
  199. #endif
  200.     case CLOSURE:
  201.             putclosure(fptr,vptr);
  202.             break;
  203.     case FREE:
  204.             putatm(fptr,"Free",vptr);
  205.             break;
  206.     default:
  207.             putatm(fptr,"Unknown",vptr);        /* was 'Foo`   TAA Mod */
  208.             break;
  209.     }
  210. }
  211.  
  212. /* xlterpri - terminate the current print line */
  213. VOID xlterpri(fptr)
  214.   LVAL fptr;
  215. {
  216.     xlputc(fptr,'\n');
  217. }
  218.  
  219. /* xlputstr - output a string */
  220. VOID xlputstr(fptr,str)
  221.   LVAL fptr; char *str;
  222. {
  223.     while (*str)
  224.         xlputc(fptr,*str++);
  225. }
  226.  
  227. /* putsymbol - output a symbol */
  228. LOCAL VOID putsymbol(fptr,str,escflag)
  229.   LVAL fptr; char *str; int escflag;
  230. {
  231.     int downcase;
  232.     LVAL type;
  233.     char *p,c;
  234.  
  235. #ifdef COMMONLISP
  236.     int i;
  237.     LVAL sym,array;
  238. #endif
  239.  
  240.     /* check for printing without escapes */
  241.     if (!escflag) {
  242.         xlputstr(fptr,str);
  243.         return;
  244.     }
  245.  
  246. #ifdef COMMONLISP
  247.     /* check for uninterned symbol -- TAA fix */
  248.     i = hash(str,HSIZE);
  249.     array = getvalue(obarray);
  250.     for (sym = getelement(array,i);sym; sym = cdr(sym))
  251.         if (strcmp(str,(char*)getstring(getpname(car(sym)))) == 0)
  252.             goto internedSymbol;
  253.         
  254.     xlputc(fptr,'#');        /* indicate uninterned */
  255.     xlputc(fptr,':');
  256.  
  257. internedSymbol:
  258. #endif
  259.     /* check to see if symbol needs escape characters */
  260. /*    if (tentry(*str) == k_const) {*/    /* always execute this code! TAA Mod*/
  261.         for (p = str; *p; ++p)
  262.             if (islower(*p)
  263.             ||    ((type = tentry(*p)) != k_const
  264.               && (!consp(type) || car(type) != k_nmacro))) {
  265.                 xlputc(fptr,'|');
  266.                 while (*str) {
  267.                     if (*str == '\\' || *str == '|')
  268.                         xlputc(fptr,'\\');
  269.                     xlputc(fptr,*str++);
  270.                 }
  271.                 xlputc(fptr,'|');
  272.                 return;
  273.             }
  274. /*    } */
  275.  
  276.     /* get the case translation flag */
  277.     downcase = (getvalue(s_printcase) == k_downcase);
  278.  
  279.     /* check for the first character being '#' */
  280.     if (*str == '#' || isnumber(str,NULL))
  281.         xlputc(fptr,'\\');
  282.  
  283.     /* output each character */
  284.     while ((c = *str++) != 0) {
  285.         /* don't escape colon until we add support for packages */
  286.         if (c == '\\' || c == '|' /* || c == ':' */)
  287.             xlputc(fptr,'\\');
  288.         xlputc(fptr,(downcase && isupper(c) ? tolower(c) : c));
  289.     }
  290. }
  291.  
  292. /* putstring - output a string */
  293. /* rewritten to     print strings containing nulls TAA mod*/
  294. LOCAL VOID putstring(fptr,str)
  295.   LVAL fptr,str;
  296. {
  297.     char* p = getstring(str);
  298.     int len = getslength(str) - 1;
  299.  
  300.     /* output each character */
  301.     while (len-- > 0) xlputc(fptr,*p++);
  302. }
  303.  
  304. /* putqstring - output a quoted string */
  305. /* rewritten to     print strings containing nulls TAA mod*/
  306. LOCAL VOID putqstring(fptr,str)
  307.   LVAL fptr,str;
  308. {
  309.     char* p = getstring(str);
  310.     int len = getslength(str) - 1;
  311.     int ch;
  312.  
  313.     /* output the initial quote */
  314.     xlputc(fptr,'"');
  315.  
  316.     /* output each character in the string */
  317.     while (len-- > 0) {
  318.         ch = *(unsigned char *)p++;
  319.  
  320.         /* check for a control character */
  321.         if (ch < 040 || ch == '\\' || ch == '"' || ch > 0176) { /* TAA MOD quote quote */
  322.             xlputc(fptr,'\\');
  323.             switch (ch) {
  324.                 case '\011':
  325.                     xlputc(fptr,'t');
  326.                     break;
  327.                 case '\012':
  328.                     xlputc(fptr,'n');
  329.                     break;
  330.                 case '\014':
  331.                     xlputc(fptr,'f');
  332.                     break;
  333.                 case '\015':
  334.                     xlputc(fptr,'r');
  335.                     break;
  336.                 case '\\':
  337.                 case '"':
  338.                     xlputc(fptr,ch);
  339.                     break;
  340.                 default:
  341.                     putoct(fptr,ch);
  342.                     break;
  343.             }
  344.         }
  345.  
  346.                 /* output a normal character */
  347.         else
  348.             xlputc(fptr,ch);
  349.     }
  350.  
  351.  
  352.     /* output the terminating quote */
  353.     xlputc(fptr,'"');
  354. }
  355.  
  356. /* putatm - output an atom */
  357. LOCAL VOID putatm(fptr,tag,val)
  358.   LVAL fptr; char *tag; LVAL val;
  359. {
  360.     sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
  361.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  362.     xlputc(fptr,'>');
  363. }
  364.  
  365. /* putsubr - output a subr/fsubr */
  366. LOCAL VOID putsubr(fptr,tag,val)
  367.   LVAL fptr; char *tag; LVAL val;
  368. {
  369. /*      sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name); */
  370.     char *str;        /* TAA mod */
  371.     if ((str = funtab[getoffset(val)].fd_name) != 0)
  372.         sprintf(buf,"#<%s-%s: #",tag,str);
  373.     else
  374.         sprintf(buf,"#<%s: #",tag);
  375.     xlputstr(fptr,buf);
  376.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  377.     xlputc(fptr,'>');
  378. }
  379.  
  380. /* putclosure - output a closure */
  381. LOCAL VOID putclosure(fptr,val)
  382.   LVAL fptr,val;
  383. {
  384.     LVAL name;
  385.     if ((name = getname(val)) != 0)
  386.         sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
  387.     else
  388.         strcpy(buf,"#<Closure: #");
  389.     xlputstr(fptr,buf);
  390.     sprintf(buf,AFMT,val); xlputstr(fptr,buf);
  391.     xlputc(fptr,'>');
  392. }
  393.  
  394. /* putfixnum - output a fixnum */
  395. LOCAL VOID putfixnum(fptr,n)
  396.   LVAL fptr; FIXTYPE n;
  397. {
  398.     char *fmt;
  399.     LVAL val;
  400.     fmt = (((val = getvalue(s_ifmt)) != 0) && stringp(val) ? getstring(val)
  401.         : IFMT);
  402.     sprintf(buf,(char *)fmt,n);
  403.     xlputstr(fptr,buf);
  404. }
  405.  
  406. /* putflonum - output a flonum */
  407. LOCAL VOID putflonum(fptr,n)
  408.   LVAL fptr; FLOTYPE n;
  409. {
  410.     char *fmt;
  411.     LVAL val;
  412.     fmt = (((val = getvalue(s_ffmt)) != 0) && stringp(val) ? getstring(val)
  413.         : "%g");
  414.     sprintf(buf,(char *)fmt,n);
  415.     xlputstr(fptr,buf);
  416. }
  417.  
  418. /* putchcode - output a character */
  419. /* modified to print control and meta characters TAA Mod */
  420. LOCAL VOID putchcode(fptr,ch,escflag)
  421.   LVAL fptr; int ch,escflag;
  422. {
  423.     if (escflag) {
  424.         xlputstr(fptr,"#\\");
  425.         if (ch > 127) {
  426.             ch -= 128;
  427.             xlputstr(fptr,"M-");
  428.         }
  429.         switch (ch) {
  430.             case '\n':
  431.                 xlputstr(fptr,"Newline");
  432.                 break;
  433.             case ' ':
  434.                 xlputstr(fptr,"Space");
  435.                 break;
  436.             case 127:
  437.                 xlputstr(fptr,"Rubout");
  438.                 break;
  439.             default:
  440.                 if (ch < 32) {
  441.                     ch += '@';
  442.                     xlputstr(fptr,"C-");
  443.                 }
  444.                 xlputc(fptr,ch);
  445.                 break;
  446.         }
  447.     }
  448.     else xlputc(fptr,ch);
  449. }
  450.  
  451. /* putoct - output an octal byte value */
  452. LOCAL VOID putoct(fptr,n)
  453.   LVAL fptr; int n;
  454. {
  455.     sprintf(buf,"%03o",n);
  456.     xlputstr(fptr,buf);
  457. }
  458.